home *** CD-ROM | disk | FTP | other *** search
- VERSION 4.00
- Begin VB.Form DissolveForm
- Caption = "Dissolve"
- ClientHeight = 3840
- ClientLeft = 1635
- ClientTop = 1230
- ClientWidth = 4890
- Height = 4530
- Left = 1575
- LinkTopic = "Form1"
- ScaleHeight = 256
- ScaleMode = 3 'Pixel
- ScaleWidth = 326
- Top = 600
- Width = 5010
- Begin VB.CommandButton CmdDissolve
- Caption = "Dissolve"
- Height = 495
- Left = 0
- TabIndex = 3
- Top = 0
- Width = 975
- End
- Begin VB.PictureBox Canvas
- AutoRedraw = -1 'True
- Height = 3810
- Left = 1080
- Picture = "DISSOLVE.frx":0000
- ScaleHeight = 250
- ScaleMode = 3 'Pixel
- ScaleWidth = 250
- TabIndex = 2
- Top = 0
- Width = 3810
- End
- Begin VB.PictureBox Pict
- AutoRedraw = -1 'True
- AutoSize = -1 'True
- Height = 3810
- Index = 1
- Left = 120
- Picture = "DISSOLVE.frx":FA5A
- ScaleHeight = 250
- ScaleMode = 3 'Pixel
- ScaleWidth = 250
- TabIndex = 1
- Top = 3840
- Visible = 0 'False
- Width = 3810
- End
- Begin VB.PictureBox Pict
- AutoRedraw = -1 'True
- AutoSize = -1 'True
- Height = 3810
- Index = 0
- Left = 0
- Picture = "DISSOLVE.frx":1F4B4
- ScaleHeight = 250
- ScaleMode = 3 'Pixel
- ScaleWidth = 250
- TabIndex = 0
- Top = 3720
- Visible = 0 'False
- Width = 3810
- End
- Begin VB.Menu mnuFile
- Caption = "&File"
- Begin VB.Menu mnuFileExit
- Caption = "E&xit"
- End
- End
- Attribute VB_Name = "DissolveForm"
- Attribute VB_Creatable = False
- Attribute VB_Exposed = False
- Option Explicit
- Dim SysPalSize As Integer
- Dim NumStaticColors As Integer
- Dim StaticColor1 As Integer
- Dim StaticColor2 As Integer
- Dim ActiveImage As Integer
- ' ***********************************************
- ' Give the form and all the picture boxes an
- ' hourglass cursor.
- ' ***********************************************
- Sub WaitStart()
- MousePointer = vbHourglass
- Canvas.MousePointer = vbHourglass
- DoEvents
- End Sub
- ' ***********************************************
- ' Restore the mouse pointers for the form and all
- ' the picture boxes.
- ' ***********************************************
- Sub WaitEnd()
- MousePointer = vbDefault
- Canvas.MousePointer = vbDefault
- End Sub
- ' ************************************************
- ' Dissolve fpic into tpic.
- ' ************************************************
- Sub Dissolve(fpic As Control, tpic As Control)
- Dim bm As BITMAP
- Dim hbm As Integer
- Dim wid As Long
- Dim hgt As Long
- Dim newbytes() As Byte
- Dim fbytes() As Byte
- Dim tbytes() As Byte
- Dim status As Long
- Dim ffrac As Single
- Dim tfrac As Single
- Dim i As Integer
- Dim j As Integer
- Dim num As Integer
- ' Get the new image's pixels.
- hbm = tpic.Image
- status = GetObject(hbm, BITMAP_SIZE, bm)
- wid = bm.bmWidthBytes
- hgt = bm.bmHeight
- ReDim tbytes(1 To wid, 1 To hgt)
- status = GetBitmapBits(hbm, wid * hgt, tbytes(1, 1))
- ' Get the old image's pixels.
- hbm = fpic.Image
- status = GetObject(hbm, BITMAP_SIZE, bm)
- wid = bm.bmWidthBytes
- hgt = bm.bmHeight
- ReDim fbytes(1 To wid, 1 To hgt)
- status = GetBitmapBits(hbm, wid * hgt, fbytes(1, 1))
- ' Make room for the new image
- ReDim newbytes(1 To wid, 1 To hgt)
- For ffrac = 1# To 0# Step -0.05
- tfrac = 1# - ffrac
- For i = 1 To wid
- For j = 1 To wid
- newbytes(i, j) = _
- NearestNonstaticGray( _
- ffrac * fbytes(i, j) + _
- tfrac * tbytes(i, j))
- Next j
- Next i
-
- status = SetBitmapBits(hbm, wid * hgt, newbytes(1, 1))
- fpic.Refresh
-
- SavePicture fpic.Image, "Diss_" & Format$(num) & ".bmp"
- num = num + 1
-
- DoEvents
- Next ffrac
- End Sub
- ' ************************************************
- ' Dissolve the new image onto the old.
- ' ************************************************
- Private Sub CmdDissolve_Click()
- ActiveImage = 1 - ActiveImage
- WaitStart
- Dissolve Canvas, Pict(ActiveImage)
- WaitEnd
- End Sub
- Private Sub Form_Load()
- Randomize
- ' Make sure the screen supports palettes.
- If Not GetDeviceCaps(hdc, RASTERCAPS) And RC_PALETTE Then
- Beep
- MsgBox "This monitor does not support palettes.", _
- vbCritical
- End
- End If
- ' Get system palette size and # static colors.
- SysPalSize = GetDeviceCaps(hdc, SIZEPALETTE)
- NumStaticColors = GetDeviceCaps(hdc, NUMRESERVED)
- StaticColor1 = NumStaticColors \ 2 - 1
- StaticColor2 = SysPalSize - NumStaticColors \ 2
- ' Get the bitmaps' bits.
- Me.Show
- WaitStart
- MatchGrayPalette Canvas
- MatchGrayPalette Pict(0)
- MatchGrayPalette Pict(1)
- Canvas.ZOrder
- DoEvents
- Pict(0).ZOrder
- DoEvents
- Pict(1).ZOrder
- DoEvents
- WaitEnd
- End Sub
- ' ************************************************
- ' Return the index of the nonstatic gray closest
- ' to the given value (assuming the non-static
- ' colors are a gray scale created by
- ' MatchGrayPalette).
- ' ************************************************
- Function NearestNonstaticGray(c As Integer) As Integer
- Dim dgray As Single
- If c < 0 Then
- c = 0
- ElseIf c > 255 Then
- c = 255
- End If
- dgray = 255 / (StaticColor2 - StaticColor1 - 2)
- NearestNonstaticGray = c / dgray + StaticColor1 + 1
- End Function
- ' ***********************************************
- ' Load the control's palette so the non-static
- ' colors are grays. Map the logical palette to
- ' match the system palette. Convert the image to
- ' use the non-static grays.
- ' ***********************************************
- Sub MatchGrayPalette(pic As Control)
- Dim logpal As Integer
- Dim sys(0 To 255) As PALETTEENTRY
- Dim palentry(0 To 255) As PALETTEENTRY
- Dim i As Integer
- Dim bm As BITMAP
- Dim hbm As Integer
- Dim status As Long
- Dim x As Integer
- Dim y As Integer
- Dim gray As Single
- Dim dgray As Single
- Dim c As Integer
- Dim clr As Integer
- Dim wid As Long
- Dim hgt As Long
- Dim bytes() As Byte
- ' Make sure pic has the foreground palette.
- pic.ZOrder
- i = RealizePalette(pic.hdc)
- DoEvents
- ' Get the system palette entries.
- i = GetSystemPaletteEntries(pic.hdc, 0, SysPalSize, sys(0))
-
- ' Get the image pixels.
- hbm = pic.Image
- status = GetObject(hbm, BITMAP_SIZE, bm)
- wid = bm.bmWidthBytes
- hgt = bm.bmHeight
- ReDim bytes(1 To wid, 1 To hgt)
- status = GetBitmapBits(hbm, wid * hgt, bytes(1, 1))
- ' Make the logical palette as big as possible.
- logpal = pic.Picture.hPal
- If ResizePalette(logpal, SysPalSize) = 0 Then
- Beep
- MsgBox "Error resizing logical palette.", _
- vbExclamation
- Exit Sub
- End If
- ' Blank the non-static colors.
- For i = 0 To StaticColor1
- palentry(i) = sys(i)
- Next i
- For i = StaticColor1 + 1 To StaticColor2 - 1
- With palentry(i)
- .peRed = 0
- .peGreen = 0
- .peBlue = 0
- .peFlags = PC_NOCOLLAPSE
- End With
- Next i
- For i = StaticColor2 To 255
- palentry(i) = sys(i)
- Next i
- i = SetPaletteEntries(logpal, 0, SysPalSize, palentry(0))
- ' Insert the non-static grays.
- gray = 0
- dgray = 255 / (StaticColor2 - StaticColor1 - 2)
- For i = StaticColor1 + 1 To StaticColor2 - 1
- c = gray
- gray = gray + dgray
- With palentry(i)
- .peRed = c
- .peGreen = c
- .peBlue = c
- End With
- Next i
- i = SetPaletteEntries(logpal, StaticColor1 + 1, StaticColor2 - StaticColor1 - 1, palentry(StaticColor1 + 1))
- ' Recreate the image using the new colors.
- For y = 1 To hgt
- For x = 1 To wid
- clr = bytes(x, y)
- With sys(clr)
- c = (CInt(.peRed) + .peGreen + .peBlue) / 3
- End With
- bytes(x, y) = NearestNonstaticGray(c)
- Next x
- Next y
- status = SetBitmapBits(hbm, wid * hgt, bytes(1, 1))
- ' Realize the gray palette.
- i = RealizePalette(pic.hdc)
- pic.Refresh
- End Sub
- Private Sub Form_Unload(Cancel As Integer)
- End
- End Sub
- Private Sub mnuFileExit_Click()
- Unload Me
- End Sub
-